home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / regexp / string-extensions.scm < prev   
Encoding:
Text File  |  1991-04-02  |  9.3 KB  |  268 lines
  1. ;;;; -*- Scheme -*-
  2. ;;;; $Header: /home/panda/pg/bevan/progs/elk/scm/RCS/string-extensions.scm,v 1.6 91/04/02 19:49:16 bevan Exp $
  3. ;;;+c
  4. ;;; Various misc. functions that operate on strings.
  5. ;;; Ideas from various languages like :- CommonLisp, Icon, Python, Perl ...
  6. ;;; The definitions here are written for portability rather than for
  7. ;;; speed.  If you really need fast versions, I suggest you re-code in
  8. ;;; a low level language like C.
  9. ;;;
  10. ;;; System : ELK
  11. ;;; System Specific Features :-
  12. ;;;   provide (as in CommonLisp)
  13. ;;;-c
  14.  
  15. ;;;+f
  16. ;;; Center the string `s1' in a string of size `width', padding on the
  17. ;;; left and right, if necessary with the string `s2'.  If `s2' is not
  18. ;;; given, then spaces are used.  If `s1' cannot be centered exactly,
  19. ;;; it is placed left of center.  Truncation is then done at the left
  20. ;;; and right as necessary.  For example :-
  21. ;;;   (string-center "Detroit" 10 "+") == "+Detroit++"
  22. ;;;   (string-center "Detroit" 6)      == "Detroi"
  23. ;;; Based on the Icon function center(s1, i, s2)
  24. ;;; Note this does not do the same thing as the Icon function for the case
  25. ;;; where `width' < (string-length s1).  If anybody can explain why the
  26. ;;; Icon function produces "etroit" in the second case, I'll be happy to
  27. ;;; change it.
  28. ;;;-f
  29. (define (string-center s1 width . s2)
  30.   (let ((padding (if s2 (car s2) " "))
  31.     (str-len (string-length s1)))
  32.     (cond ((> width str-len)
  33.        (let* ((left (quotient (- width str-len) 2))
  34.           (right (- width (+ left str-len))))
  35.          (string-append (string-replw padding left)
  36.                 s1
  37.                 (string-replw padding right))))
  38.       ((< width str-len)
  39.        (let* ((left (quotient (- str-len width) 2))
  40.           (right (+ left width)))
  41.          (substring s1 left right)))
  42.       (else s1))))
  43.   
  44. ;;; The Scheme below is a loose translation of some Python code
  45. ;;; by Guido van Rossum, CWI Amsterdam <guido@cwi.nl>
  46. ;;;
  47. ;;;+f
  48. ;;; Look for the string `substr' in the string `str'
  49. ;;; If it is there, return the position of the start of it, otherwise
  50. ;;; return #false
  51. ;;;-f
  52. ;;; Note the current method is very poor for long strings.
  53. ;;; Should implement a Boyer-Moore or some other fast search.
  54. ;;;
  55. (define (string-find-string str substr . optional-start)
  56.   (let* ((start (if optional-start (car optional-start) 0))
  57.      (len-substr (string-length substr))
  58.      (len-str (string-length str))
  59.      (max (- len-str len-substr)))
  60.     (let loop ((left start))
  61.       (cond ((> left max) #f)
  62.         ((string=? (substring str left (+ left len-substr)) substr) left)
  63.         (else (loop (+ 1 left)))))))
  64.  
  65. ;;;+f
  66. ;;; Look for the character `chr' in the string `str' optionally starting
  67. ;;; at position `start-pos'
  68. ;;; Returns the first position in the string at which the character is found
  69. ;;; of #f if the character wasn't found.
  70. ;;;-f
  71. (define (string-find-char str chr . start-pos)
  72.   (let ((len (string-length str)))
  73.     (let find ((pos (if start-pos (car start-pos) 0)))
  74.       (cond ((>= pos len) #f)
  75.         ((char=? (string-ref str pos) chr) pos)
  76.         (else (find (+ 1 pos)))))))
  77.          
  78. ;;;+f
  79. ;;; Checks if the string `prefix' is a prefix of the string `str'
  80. ;;; If it is it returns #t
  81. ;;;-f
  82. ;;; This is a loose translation of the following C by Karl Heuer.
  83. ;;;
  84. ;;; char *strpref(char const *s, char const *t) {
  85. ;;;    while (*t != '\0') if (*s++ != *t++) return (NULL);
  86. ;;;    return ((char *)s);
  87. ;;; }
  88. ;;;
  89. (define (string-prefix? str prefix)
  90.   (let ((prefix-len (string-length prefix))
  91.     (str-len (string-length str)))
  92.     (let loop ((str-pos 0))
  93.       (cond ((= str-pos prefix-len) #t)
  94.         ((= str-pos str-len) (<= prefix-len str-len))
  95.         ((char=? (string-ref str str-pos) (string-ref prefix str-pos))
  96.          (loop (+ 1 str-pos)))
  97.         (else #f)))))
  98.  
  99. ;;; The Scheme below is an implementation of the following C function.
  100. ;;; Description is by Dan Bernstein <brnstnd@kramden.acf.nyu.edu>
  101. ;;;
  102. ;;;  int strinfdiff(sf,tf) returns 0 if sf and tf are the same, -1 if sf is
  103. ;;;  a prefix of tf, -2 if it is not a prefix but is strictly smaller
  104. ;;;  (compared in dictionary order with individual chars unsigned), 1 if tf
  105. ;;;  is a prefix of sf, and 2 if tf is smaller than sf but not a prefix.
  106. ;;;
  107. (define (string-diff a b)
  108.   (error 'string-diff "not implemented yet"))
  109.  
  110. ;;;+f
  111. ;;; Produce a string of size `width' in which the string `s1' is positioned
  112. ;;; at the left and `s2' is used to pad out the remaining characters to
  113. ;;; the right.  For example :-
  114. ;;;   (string-left "Detroit" 10 "+") == "Detroit+++"
  115. ;;;   (string-left "Detroit" 6)      == "Detroi"
  116. ;;; Based on the Icon function left(s1, i, s2)
  117. ;;;-f
  118. (define (string-left s1 width . s2)
  119.   (let ((padding (if s2 (car s2) " "))
  120.     (str-len (string-length s1)))
  121.     (cond ((> width str-len)
  122.        (string-append s1 (string-replw padding (- width str-len))))
  123.       ((< width str-len) (substring s1 0 width))
  124.       (else s1))))
  125.  
  126. ;;;+f
  127. ;;; Generate `copies' number of copies of the string `str'
  128. ;;; For example :-
  129. ;;;   (string-replc "+*+" 3) == "+*++*++*+"
  130. ;;;   (string-replc s 0) == ""
  131. ;;; Based on the Icon function repl(s, i)
  132. ;;; Returns : string
  133. ;;;-f
  134. (define (string-replc str copies)
  135.   (let loop ((result "") (count copies))
  136.     (if (zero? count)
  137.     result
  138.     (loop (string-append str result) (- count 1)))))
  139.  
  140. ;;;+f
  141. ;;; Geneate a string which is `width' characters long consisting on the
  142. ;;; given string `str'.  For example :-
  143. ;;;   (string-replw "abc" 10) == "abcabcabca"
  144. ;;;   (string-replw "abc" 1)  == "a"
  145. ;;;   (string-replw "abc" 0)  == ""
  146. ;;;   (string-replw ""    1)  == ""
  147. ;;;-f
  148. (define (string-replw str width)
  149.   (if (string=? str "")
  150.       ""
  151.       (let ((str-len (string-length str)))
  152.     (let loop ((result "") (size 0))
  153.       (cond ((= size width) result)
  154.         ((> size width) (substring result 0 width))
  155.         (else (loop (string-append result str) (+ size str-len))))))))
  156.  
  157. ;;;+f
  158. ;;; Produces a string consisting of the characters of the string `str'
  159. ;;; in reverse order.  For example :-
  160. ;;;   (string-reverse "string") == "gnirts"
  161. ;;;   (string-reverse "") == ""
  162. ;;; Based on the Icon function reverse(s)
  163. ;;; Returns : string
  164. ;;;-f
  165. (define (string-reverse str)
  166.   (let ((result (make-string (string-length str) #\Space)))
  167.     (let loop ((low 0) (high (string-length str)))
  168.       (if (zero? high)
  169.       result
  170.       (begin
  171.         (let ((new-high (- high 1)))
  172.           (string-set! result low (string-ref str new-high))
  173.           (loop (+ 1 low) new-high)))))))
  174.  
  175. ;;;+f
  176. ;;; Produce a string of size `width' in which the string `s1' is positioned
  177. ;;; at the right and `s2' is used to pad out the remaining characters to
  178. ;;; the left.  For example :-
  179. ;;;   (string-right "Detroit" 10 "+") == "+++Detroit"
  180. ;;;   (string-right "Detroit" 6)      == "etroit"
  181. ;;; Based on the Icon function right(s1, i, s2)
  182. ;;;-f
  183. (define (string-right s1 width . s2)
  184.   (let ((padding (if s2 (car s2) " "))
  185.     (str-len (string-length s1)))
  186.     (cond ((> width str-len)
  187.        (string-append (string-replw padding (- width str-len)) s1))
  188.       ((< width str-len) (substring s1 (- str-len width) str-len))
  189.       (else s1))))
  190.  
  191. ;;; The Scheme below is a loose translation of the following Python code
  192. ;;; by Guido van Rossum, CWI Amsterdam <guido@cwi.nl>
  193. ;;;
  194. ;;; # Split a string into a list of space/tab-separated words
  195. ;;; # NB: split(s) is NOT the same as splitfields(s, ' ')!
  196. ;;; def split(s):
  197. ;;;    res = []
  198. ;;;    i, n = 0, len(s)
  199. ;;;    while i < n:
  200. ;;;        while i < n and s[i] in whitespace: i = i+1
  201. ;;;        if i = n: break
  202. ;;;        j = i
  203. ;;;        while j < n and s[j] not in whitespace: j = j+1
  204. ;;;        res.append(s[i:j])
  205. ;;;        i = j
  206. ;;;    return res
  207. ;;;+f
  208. ;;; Returns a list of whitespace delimited words in the string `str'.
  209. ;;; If the string is empty or contains only whitespace, then
  210. ;;; it returns the empty list.
  211. ;;;-f
  212. (define (string-split-whitespace str)
  213.   (define (skip-whitespace str pos)
  214.     (cond ((zero? pos) pos)
  215.       ((char-whitespace? (string-ref str pos))
  216.        (skip-whitespace str (- pos 1)))
  217.       (else pos)))
  218.   (define (skip-non-whitespace str pos)
  219.     (cond ((zero? pos)
  220.        (if (char-whitespace? (string-ref str pos))
  221.            (+ 1 pos)
  222.            pos))
  223.       ((char-whitespace? (string-ref str pos)) (+ 1 pos))
  224.       (else (skip-non-whitespace str (- pos 1)))))
  225.       (define (string-split-tr str pos result)
  226.     (let ((end (skip-whitespace str pos)))
  227.       (if (zero? end)
  228.       result
  229.       (let* ((start (skip-non-whitespace str end))
  230.          (new-result (cons (substring str start (+ 1 end)) result)))
  231.         (if (zero? start)
  232.         new-result
  233.         (string-split-tr str (- start 1) new-result))))))
  234.   (let ((result '())
  235.         (strlen (string-length str)))
  236.     (if (zero? strlen)
  237.     result
  238.     (string-split-tr str (- strlen 1) result))))
  239.  
  240. ;;; The Scheme below is a loose translation of the following Python code
  241. ;;; by Guido van Rossum, CWI Amsterdam <guido@cwi.nl>
  242. ;;; 
  243. ;;; # Strip leading and trailing tabs and spaces
  244. ;;; def strip(s):
  245. ;;;    i, j = 0, len(s)
  246. ;;;    while i < j and s[i] in whitespace: i = i+1
  247. ;;;    while i < j and s[j-1] in whitespace: j = j-1
  248. ;;;    return s[i:j]
  249. ;;;+f
  250. ;;; Strip the leading and trailing whitespace from the string `str'
  251. ;;;-f
  252. (define (string-trim-whitespace str)
  253.   (define (string-trim-left str left len)
  254.     (if (and (< left len) (char-whitespace? (string-ref str left)))
  255.     (string-trim-left str (+ 1 left) len)
  256.     left))
  257.   (define (string-trim-right str left right)
  258.     (if (and (< left right) (char-whitespace? (string-ref str (- right 1))))
  259.     (string-trim-right str left (- right 1))
  260.     right))
  261.   (let* ((len (string-length str))
  262.      (left (string-trim-left str 0 len))
  263.      (right (string-trim-right str left len)))
  264.     (substring str left right)))
  265.  
  266.  
  267. (provide 'string-extensions)
  268.